home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 1997 May / PC Plus Super CD Issue 127 (May 1997).iso / delphi2 / delphite.exe / data.z / OLEAUTO.INT < prev    next >
Encoding:
Text File  |  1996-08-12  |  7.1 KB  |  214 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {                                                       }
  6. {       Copyright (c) 1996 Borland International        }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit OleAuto;
  11.  
  12. {$R-}
  13.  
  14. interface
  15.  
  16. uses Windows, Ole2, OleCtl, SysUtils;
  17.  
  18. const
  19.  
  20. { Maximum number of dispatch arguments }
  21.  
  22.   MaxDispArgs = 32;
  23.  
  24. type
  25.  
  26. { Forward declarations }
  27.  
  28.   TAutoObject = class;
  29.  
  30. { Dispatch interface for TAutoObject }
  31.  
  32.   TAutoDispatch = class(IDispatch)
  33.   public
  34.     constructor Create(AutoObject: TAutoObject);
  35.     function QueryInterface(const iid: TIID; var obj): HResult; override;
  36.     function AddRef: Longint; override;
  37.     function Release: Longint; override;
  38.     function GetTypeInfoCount(var ctinfo: Integer): HResult; override;
  39.     function GetTypeInfo(itinfo: Integer; lcid: TLCID;
  40.       var tinfo: ITypeInfo): HResult; override;
  41.     function GetIDsOfNames(const iid: TIID; rgszNames: POleStrList;
  42.       cNames: Integer; lcid: TLCID; rgdispid: PDispIDList): HResult; override;
  43.     function Invoke(dispIDMember: TDispID; const iid: TIID; lcid: TLCID;
  44.       flags: Word; var dispParams: TDispParams; varResult: PVariant;
  45.       excepInfo: PExcepInfo; argErr: PInteger): HResult; override;
  46.     function GetAutoObject: TAutoObject; virtual; stdcall;
  47.     property AutoObject: TAutoObject;
  48.   end;
  49.  
  50. { TAutoObject - Automation object base class. An automation class is
  51.   implemented by deriving a new class from TAutoObject, and declaring methods
  52.   and properties in an "automated" section in the new class. To expose an
  53.   automation class to external OLE Automation Controllers, the unit that
  54.   implements the automation class must call Automation.RegisterClass in its
  55.   initialization section, passing in a TAutoClassInfo structure. Once a
  56.   class has been registered in this way, the global Automation object
  57.   automatically manages all aspects of interfacing with the OLE Automation
  58.   APIs.
  59.  
  60.   When an external OLE Automation Controller requests an instance of an
  61.   automation class, the Create constructor is called to create the object,
  62.   and when all external references to the object disappear, the Destroy
  63.   destructor is called to destroy the object. As is the case with all OLE
  64.   objects, automation objects are reference counted. }
  65.  
  66.   TAutoObject = class(TObject)
  67.   protected
  68.     function CreateAutoDispatch: TAutoDispatch; virtual;
  69.     procedure GetExceptionInfo(ExceptObject: TObject;
  70.       var ExcepInfo: TExcepInfo); virtual;
  71.   public
  72.     constructor Create; virtual;
  73.     destructor Destroy; override;
  74.     function AddRef: Integer;
  75.     function Release: Integer;
  76.     property AutoDispatch: TAutoDispatch;
  77.     property OleObject: Variant;
  78.     property RefCount: Integer;
  79.   end;
  80.  
  81. { Automation object class reference }
  82.  
  83.   TAutoClass = class of TAutoObject;
  84.  
  85. { Instancing mode for local server automation classes }
  86.  
  87.   TAutoClassInstancing = (acInternal, acSingleInstance, acMultiInstance);
  88.  
  89. { Automation class registration info }
  90.  
  91.   TAutoClassInfo = record
  92.     AutoClass: TAutoClass;
  93.     ProgID: string;
  94.     ClassID: string;
  95.     Description: string;
  96.     Instancing: TAutoClassInstancing;
  97.   end;
  98.  
  99. { Class registry entry }
  100.  
  101.   TRegistryClass = class
  102.   public
  103.     constructor Create(const AutoClassInfo: TAutoClassInfo);
  104.     destructor Destroy; override;
  105.     procedure UpdateRegistry(Register: Boolean);
  106.   end;
  107.  
  108. { Application start mode }
  109.  
  110.   TStartMode = (smStandalone, smAutomation, smRegServer, smUnregServer);
  111.  
  112. { Automation manager event types }
  113.  
  114.   TLastReleaseEvent = procedure(var Shutdown: Boolean) of object;
  115.  
  116. { Automation manager object }
  117.  
  118.   TAutomation = class
  119.   public
  120.     constructor Create;
  121.     destructor Destroy; override;
  122.     procedure RegisterClass(const AutoClassInfo: TAutoClassInfo);
  123.     procedure UpdateRegistry(Register: Boolean);
  124.     property AutoObjectCount: Integer;
  125.     property IsInprocServer: Boolean;
  126.     property StartMode: TStartMode;
  127.     property OnLastRelease: TLastReleaseEvent;
  128.   end;
  129.  
  130. { OLE exception classes }
  131.  
  132.   EOleError = class(Exception);
  133.  
  134.   EOleSysError = class(EOleError)
  135.   public
  136.     constructor Create(ErrorCode: Integer);
  137.     property ErrorCode: Integer;
  138.   end;
  139.  
  140.   EOleException = class(EOleError)
  141.   public
  142.     constructor Create(const ExcepInfo: TExcepInfo);
  143.     property ErrorCode: Integer;
  144.     property HelpFile: string;
  145.     property Source: string;
  146.   end;
  147.  
  148. { Dispatch call descriptor }
  149.  
  150.   PCallDesc = ^TCallDesc;
  151.   TCallDesc = packed record
  152.     CallType: Byte;
  153.     ArgCount: Byte;
  154.     NamedArgCount: Byte;
  155.     ArgTypes: array[0..255] of Byte;
  156.   end;
  157.  
  158. var
  159.   Automation: TAutomation;
  160.  
  161. { CreateOleObject creates an OLE automation object of the given class. }
  162.  
  163. function CreateOleObject(const ClassName: string): Variant;
  164.  
  165. { GetActiveOleObject returns the active object for the given class. }
  166.  
  167. function GetActiveOleObject(const ClassName: string): Variant;
  168.  
  169. { The DllXXXX routines implement the required entry points of an in-process
  170.   automation server DLL. These routines must be exported by the DLL using
  171.   an "exports" clause in the library's main module. }
  172.  
  173. function DllGetClassObject(const CLSID: TCLSID; const IID: TIID;
  174.   var Obj): HResult; stdcall;
  175. function DllCanUnloadNow: HResult; stdcall;
  176. function DllRegisterServer: HResult; stdcall;
  177. function DllUnregisterServer: HResult; stdcall;
  178.  
  179. { VarFromInterface returns a variant that contains the a reference to the
  180.   IDispatch interface of the given IUnknown interface. If the Unknown
  181.   parameter is NIL, the resulting variant is set to Unassigned. }
  182.  
  183. function VarFromInterface(Unknown: IUnknown): Variant;
  184.  
  185. { VarToInterface returns the IDispatch interface reference stored in the
  186.   given variant. An exception is raised if the variant does not contain
  187.   an IDispatch interface. VarToInterface does not affect the reference
  188.   count of the returned IDispatch. The caller of VarToInterface must
  189.   manually call AddRef and Release on the returned interface. }
  190.  
  191. function VarToInterface(const V: Variant): IDispatch;
  192.  
  193. { VarToAutoObject returns the TAutoObject instance corresponding to the
  194.   IDispatch interface reference stored in the given variant. An exception
  195.   is raised if the variant does not contain an IDispatch interface, or if
  196.   the IDispatch interface is not that of a TAutoObject instance. }
  197.  
  198. function VarToAutoObject(const V: Variant): TAutoObject;
  199.  
  200. procedure DispInvoke(Dispatch: IDispatch; CallDesc: PCallDesc;
  201.   DispIDs: PDispIDList; Params: Pointer; Result: PVariant);
  202. procedure DispInvokeError(Status: Integer; const ExcepInfo: TExcepInfo);
  203.  
  204. procedure OleError(ErrorCode: HResult);
  205. procedure OleCheck(Result: HResult);
  206.  
  207. function StringToClassID(const S: string): TCLSID;
  208. function ClassIDToString(const ClassID: TCLSID): string;
  209.  
  210. function ProgIDToClassID(const ProgID: string): TCLSID;
  211. function ClassIDToProgID(const ClassID: TCLSID): string;
  212.  
  213. implementation
  214.